home *** CD-ROM | disk | FTP | other *** search
/ Shareware Overload Trio 2 / Shareware Overload Trio Volume 2 (Chestnut CD-ROM).ISO / dir30 / springs.zip / SPRINGHK.LSP < prev    next >
Lisp/Scheme  |  1994-03-08  |  6KB  |  182 lines
  1. (defun C:HK (/ OD MD WD A A1 A2 A3 A4
  2.           N N1 PTCH PTCHO2 TWOPI PIO2 WO2 PC3
  3.           PC2 PC1 MA P1 P2 P3 P4 P5 P6 P7 P8 P9 PC2T
  4.           DIST DIST2 MPIO2 TANNA Q1 Q2 Q3 Q4 PH AR1
  5.           AR2 AR3 AR4 X1 XE A3R D1 PR P1R P2R P3R
  6.           P4R P5R P6R P7R P8R P9R P10R P1E P9E SP
  7.           SPR EHR A270 P1E EHR)
  8.      (command "cmdecho" 0)
  9.      (setvar "osmode" 0)
  10.      (setvar "lunits" 2)
  11.      (defun dtr (A) (* PI (/ A 180.0)))
  12.      (defun tana (A) (/ (sin A) (cos A)))
  13.      (setq P0 (getpoint "\nLocate Start  "))
  14.      (princ "\nOutside Diameter <")
  15.      (princ OD*)(princ "> ")
  16.      (setq OD (getdist))(if (= OD NIL)
  17.      (setq OD OD*)(setq OD* OD))
  18.      (princ "\nWire Diameter <")
  19.      (princ WD*)(princ "> ")
  20.      (setq WD (getdist))(if (= WD NIL)
  21.      (setq WD WD*)(setq WD* WD))
  22.      (princ "\nPitch <")
  23.      (princ PTCH*)(princ "> ")
  24.      (setq PTCH (getdist))(if (= PTCH NIL)
  25.      (setq PTCH PTCH*)(setq PTCH* PTCH))
  26.      (princ "\nNumber of Turns <")
  27.      (princ N1*)(princ "> ")
  28.      (setq N1 (getreal))(if (= N1 NIL)
  29.      (setq N1 N1*)(setq N1* N1))
  30.      (prompt "Left hook  ")
  31.      (prompt "**************************")
  32.      (princ "\n1st Radius for hook  <")
  33.      (princ R2*)(princ "> ")
  34.      (setq R2 (getdist))(if (= R2 Nil)
  35.      (setq R2 R2*)(setq R2* R2))
  36.      (princ "\nLength of Straight Part of Hook  <")
  37.      (princ SP*)(princ "> ")
  38.      (setq SP (getdist))(if (= SP Nil)
  39.      (setq SP SP*)(setq SP* SP))
  40.      (if (= 0 SP)(setq SP 1.0E-07))
  41.      (princ "\nLength of End of Hook  <")
  42.      (princ EH*)(princ "> ")
  43.      (setq EH (getdist))(if (= EH NIL)
  44.      (setq EH EH*)(setq EH* EH))
  45.      (if (= 0 EH)(setq EH 1.0E-07))
  46.      (prompt "Right hook  ")
  47.      (prompt "**************************")
  48.      (princ "\n1st Radius for hook  <")
  49.      (princ R2R*)(princ "> ")
  50.      (setq R2R (getdist))(if (= R2R Nil)
  51.      (setq R2R R2R*)(setq R2R* R2R))
  52.      (princ "\nLength of Straight Part of Hook  <")
  53.      (princ SPR*)(princ "> ")
  54.      (setq SPR (getdist))(if (= SPR Nil)
  55.      (setq SPR SPR*)(setq SPR* SPR))
  56.      (if (= 0 SPR)(setq SPR 1.0E-07))
  57.      (princ "\nLength of End of Hook  <")
  58.      (princ EHR*)(princ "> ")
  59.      (setq EHR (getdist))(if (= EHR NIL)
  60.      (setq EHR EHR*)(setq EHR* EHR))
  61.      (if (= 0 EHR)(setq EHR 1.0E-07))
  62.      (setq WO2 (/ WD 2.0))   
  63.      (setq MD (- OD WD))
  64.      (setq PTCHO2 (/ PTCH 2.0))
  65.      (setq Q1 (/ PTCHO2 (- OD WD)))
  66.      (setq A (ATAN Q1))
  67.      (setq A1 (+ PI A))
  68.      (setq A2 (- PI A))
  69.      (setq TWOPI (+ PI PI))
  70.      (setq PIO2 (/ PI 2.0))
  71.      (setq A3 (+ PIO2 A))
  72.      (setq A4 (- PIO2 A))
  73.      (setq PC1 (polar P0 PIO2 WO2))
  74.      (setq DIST2 (/ WO2 (SIN A)))
  75.      (setq PC3 (polar PC1 0 PTCH))
  76.      (setq P8 (polar PC3 PIO2 DIST2))
  77.      (setq PE (polar P8 PI PTCH))
  78.      (setq MA (- TWOPI A))
  79.      (setq PH (polar PC1 A1 WO2))
  80.      (setvar "lunits" 2)
  81.      (setq PBOX (getvar "pickbox"))
  82.      (setvar "pickbox" 1)
  83.      (setq PREC (getvar "luprec"))
  84.      (setvar "luprec" 8)
  85.      ;(setvar "blipmode" 0)
  86.      (setq N (- N1 1.0))
  87.      (setq TEST 0)
  88.      (while (<= TEST N)
  89.           (setq P1 (polar PC1 MA WO2))
  90.           (setq P1E P1)
  91.           (setq P2 (polar PC1 A2 WO2))
  92.           (setq PC2T (polar PC1 PIO2 MD))
  93.           (setq TANNA (tana A))
  94.           (setq PC2 (polar PC2T 0 (* MD TANNA)))
  95.           (setq DIST (* MD (tana A)))
  96.           (setq P4 (polar PC2 MA WO2))
  97.           (setq P3 (polar PC2 A2 WO2))
  98.           (setq PC3 (polar PC1 0 PTCH))
  99.           (setq P5 (polar PC3 A1 WO2))
  100.           (setq P6 (polar PC3 MA WO2))
  101.           (setq P7 (polar PC2 A WO2))
  102.           (setq PR P7)
  103.           (setq P8 (polar PC3 PIO2 DIST2))
  104.           (setq MPIO2 (* 1.5 PI))
  105.           (setq P9 (polar PC2 MPIO2 DIST2))
  106.           (setq P9R P9)
  107.           (setq P9E P9)
  108.         (command "pline" P4 "W" 0 0 P1 "A" P2 "L" P3 "A" P4 "")
  109.           (command "pline" P9 P5 "A" P6 "")
  110.           (command "pline" P8 P7 "")
  111.           (setq PC1 (polar PC1 0 PTCH))
  112.           (setq TEST (+ TEST 1.0))
  113.       )
  114.       (command "erase" P5 "")
  115.       (command "erase" P8 "")
  116.       (setq SINA (sin A))
  117.       (setq Q1 (- 1.0 SINA))
  118.       (setq Q1 (* WO2 Q1))
  119.       (setq Q2 (* R2 SINA))
  120.       (setq Q3 (+ R2 WD))
  121.       (setq VD (- (+ OD Q2) (+ Q1 Q3)))
  122.       (setq D1 (/ VD (cos A)))
  123.       (setq P1 (polar PH A3 D1))
  124.       (setq AR1 (- PIO2 A))
  125.       (setq AR2 (/ (+ PIO2 A) 2.0))
  126.       (setq Q4 (/ (sin AR1) (sin AR2)))
  127.       (setq D2 (* Q4 R2))
  128.       (setq AR3 (+ (- PIO2 AR2) A PIO2))
  129.       (setq AR4 (+ PI AR3))
  130.       (setq D3 (* Q4 Q3))
  131.       (setq P2 (polar P1 AR3 D2))
  132.       (setq P3 (polar P2 PI SP))
  133.       (setq DH (- OD (* 2.0 WD)))
  134.       (setq A270 (* 1.5 PI))
  135.       (setq P4 (polar P3 A270 DH))
  136.       (setq P5 (polar P4 0 EH))
  137.       (setq P6 (polar P5 A270 WD))
  138.       (setq P7 (polar P6 PI EH))
  139.       (setq P8 (polar P7 PIO2 OD))
  140.       (setq P9 (polar P8 0 SP))
  141.       (setq P10 (polar P9 AR4 D3))
  142.       (setq X1 (car P10))
  143.       (setq XE (car PE))
  144.       (command "pline" PH P1 "A" P2 "L" P3 "A" P4 "L" P5 P6
  145.                P7 "A" P8 "L" P9 "A" P10 "L" PE "")
  146.       (if (> X1 XE)(command "trim" P0 "" P10 ""))
  147.       (setq Q2 (* R2R SINA))
  148.       (setq Q3 (+ R2R WD))
  149.       (setq VD (- (+ OD Q2) (+ Q1 Q3)))
  150.       (setq D1 (/ VD (cos A)))
  151.       (setq A3R (+ PI A3))
  152.       (setq P1R (polar PR A3R D1))
  153.       (setq AR1 (- PIO2 A))
  154.       (setq AR2 (/ (+ PIO2 A) 2.0))
  155.       (setq Q4 (/ (sin AR1) (sin AR2)))
  156.       (setq D2 (* Q4 R2R))
  157.       (setq AR3 (+ (- PIO2 AR2) A PIO2))
  158.       (setq AR3 (+ AR3 PI))
  159.       (setq AR4 (+ PI AR3))
  160.       (setq D3 (* Q4 Q3))
  161.       (setq P2R (polar P1R AR3 D2))
  162.       (setq P3R (polar P2R 0 SPR))
  163.       (setq P4R (polar P3R PIO2 DH))
  164.       (setq P5R (polar P4R PI EHR))
  165.       (setq P6R (polar P5R PIO2 WD))
  166.       (setq P7R (polar P6R 0 EHR))
  167.       (setq P8R (polar P7R A270 OD))
  168.       (setq P9R (polar P8R PI SPR))
  169.       (setq P10R (polar P9R AR4 D3))
  170.       (setq X1 (car P10R))
  171.       (setq XE (car P9E))
  172.       (command "pline" PR P1R "A" P2R "L" P3R "A" P4R "L" P5R
  173.       P6R P7R "A" P8R "L" P9R "A" P10R "L" P9E "")
  174.       (if (< X1 XE)(command "trim" P1E "" P9E ""))
  175.       (if (< X1 XE)(command "trim" P1E "" P10R ""))
  176.       (setvar "osmode" 1)
  177.       (command "cmdecho" 1)
  178.       ;(setvar "blipmode" 1)
  179.       (setvar "pickbox" PBOX)
  180.       (setvar "luprec" PREC)
  181. );end springhk.lsp
  182.